home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / specials.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-06-18  |  18.0 KB  |  757 lines
  1. /* ******************************************************************** */
  2. /* specials.c        Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Language special forms (NOT toplevel forms)                          */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: specials.c,v 1.16 1992/06/12 00:00:55 pab Exp $
  9.  *
  10.  * $Log: specials.c,v $
  11.  * Revision 1.16  1992/06/12  00:00:55  pab
  12.  * fixed tagbody
  13.  *
  14.  * Revision 1.15  1992/05/28  11:28:26  pab
  15.  * GC protect
  16.  *
  17.  * Revision 1.14  1992/05/19  11:26:37  pab
  18.  * tagbody (blech blech) fixed
  19.  *
  20.  * Revision 1.13  1992/04/30  19:42:18  pab
  21.  * fixed setq(!)
  22.  *
  23.  * Revision 1.12  1992/04/27  21:59:49  pab
  24.  * fixed env stacks
  25.  *
  26.  * Revision 1.11  1992/04/26  21:07:07  pab
  27.  * 'lost ' handler code
  28.  *
  29.  * Revision 1.10  1992/03/07  21:45:16  pab
  30.  * initial continuation changes
  31.  *
  32.  * Revision 1.9  1992/02/10  16:41:09  pab
  33.  * fixed dynamics properly
  34.  *
  35.  * Revision 1.8  1992/01/29  13:47:28  pab
  36.  * bindig fix, gc fix in dynamic let
  37.  *
  38.  * Revision 1.7  1992/01/09  22:29:05  pab
  39.  * Fixed for low tag ints
  40.  *
  41.  * Revision 1.6  1992/01/07  22:13:27  pab
  42.  * *** empty log message ***
  43.  *
  44.  * Revision 1.5  1992/01/05  22:48:20  pab
  45.  * Minor bug fixes, plus BSD version
  46.  *
  47.  * Revision 1.4  1991/12/22  15:14:34  pab
  48.  * Xmas revision
  49.  *
  50.  * Revision 1.3  1991/09/22  19:14:40  pab
  51.  * Fixed obvious bugs
  52.  *
  53.  * Revision 1.2  1991/09/11  12:07:40  pab
  54.  * 11/9/91 First Alpha release of modified system
  55.  *
  56.  * Revision 1.1  1991/08/12  16:50:00  pab
  57.  * Initial revision
  58.  *
  59.  * Revision 1.4  1991/02/13  18:28:55  kjp
  60.  * Pass.
  61.  *
  62.  */
  63.  
  64. /*
  65.  * Change Log:
  66.  *   Version 1, March 1990 (Compiler rationalisation)
  67.  *     New fully working let/cc and unwind-protect - 
  68.  *       all stacks dealt with and dead continuations killed (KJP)
  69.  */
  70.  
  71. #include "defs.h"
  72. #include "structs.h"
  73. #include "funcalls.h"
  74. #include "error.h"
  75. #include "global.h"
  76.  
  77. #include "slots.h"
  78. #include "garbage.h"
  79.  
  80. #include "symboot.h"
  81. #include "modules.h"
  82. #include "root.h"
  83. #include "allocate.h"
  84. #include "specials.h"
  85. #include "toplevel.h"
  86. #include "state.h"
  87.  
  88. /*
  89.  
  90.  * We're talking just the non-toplevel restricted special forms here
  91.  * like lambda, setq, and if - the ones always available.
  92.  
  93.  */
  94.  
  95. LispObject special_table;
  96.  
  97. LispObject my_make_special(LispObject *stacktop,
  98.                char *name, LispObject (*func)())
  99. {
  100.   LispObject ans,tmp;
  101.  
  102.   ans = (LispObject) get_symbol(stacktop,name);
  103.   STACK_TMP(ans);
  104.   tmp = (LispObject) allocate_special(stacktop,ans,func);
  105.   UNSTACK_TMP(ans);
  106.   ans->SYMBOL.lvalue=tmp;
  107.   STACK_TMP(ans);
  108.   EUCALL_3(tref_updator,special_table,ans,ans->SYMBOL.lvalue);
  109.   UNSTACK_TMP(ans);
  110.   return(ans->SYMBOL.lvalue);
  111. }
  112.  
  113. EUFUN_1( Fn_special_form_p, name)
  114. {
  115.   return(EUCALL_2(Fn_tref,special_table,name));
  116. }
  117. EUFUN_CLOSE
  118.  
  119. LispObject special_lambda;
  120. EUFUN_3( Sf_lambda, mod, env, forms)
  121. {
  122.   LispObject bvl,myforms;
  123.   LispObject ans,walker;
  124.   int i;
  125.  
  126.   if (forms == nil) {
  127.     CallError(stacktop,"lambda: illegal empty lambda form",nil,NONCONTINUABLE);
  128.   }
  129.  
  130.   myforms = forms;
  131.  
  132.   bvl = CAR(myforms); myforms = CDR(myforms);
  133.   STACK_TMP(bvl); STACK_TMP(myforms);
  134.  
  135.   walker = bvl; i = 0;
  136.   while (is_cons(walker)) {
  137.     walker = CDR(walker);
  138.     ++i;
  139.   }
  140.  
  141.   if (walker != nil)  /* improper lambda list */
  142.     ans = (LispObject) allocate_i_function(stacktop,mod,env,-i -1);
  143.   else
  144.     ans = (LispObject) allocate_i_function(stacktop,mod,env,i);
  145.  
  146.   UNSTACK_TMP(myforms); UNSTACK_TMP(bvl);
  147.   ans->I_FUNCTION.bvl  = bvl;
  148.   ans->I_FUNCTION.body = myforms;
  149.   ans->I_FUNCTION.home = ARG_0(stackbase);
  150.  
  151.   return ans;
  152. }
  153. EUFUN_CLOSE
  154.  
  155. LispObject special_macro_lambda;
  156. EUFUN_3(Sf_mlambda, mod, env, forms)
  157. {
  158.   LispObject bvl;
  159.   LispObject ans,walker;
  160.   int i;
  161.  
  162.   if (forms == nil) {
  163.     CallError(stacktop,
  164.           "macro-lambda: illegal empty macro-lambda form",nil,NONCONTINUABLE);
  165.   }
  166.  
  167.   bvl = CAR(forms); forms = CDR(forms);
  168.   ARG_2(stackbase)=forms;
  169.   walker = bvl; i = 0;
  170.   while (is_cons(walker)) {
  171.     walker = CDR(walker);
  172.     ++i;
  173.   }
  174.   STACK_TMP(bvl);
  175.   if (walker != nil)  /* improper lambda list */
  176.     ans = (LispObject) allocate_i_function(stacktop,mod,env,-i -1);
  177.   else
  178.     ans = (LispObject) allocate_i_function(stacktop,mod,env,i);
  179.  
  180.   UNSTACK_TMP(bvl);
  181.   lval_typeof(ans) = TYPE_I_MACRO;
  182.   ans->I_MACRO.bvl  = bvl;
  183.   ans->I_MACRO.body = ARG_2(stackbase)/*forms*/;
  184.   ans->I_MACRO.home = ARG_0(stackbase)/*mod*/;
  185.  
  186.   return ans;
  187. }
  188. EUFUN_CLOSE
  189.  
  190. LispObject special_setq;
  191. EUFUN_3( Sf_setq,  mod, env, forms)
  192. {
  193.   LispObject id;
  194.  
  195.   if (forms == nil) 
  196.     CallError(stacktop,"setq: illegal empty setq form",nil,NONCONTINUABLE);
  197.  
  198.   id = CAR(forms); forms = CDR(forms);
  199.  
  200.   if (!is_symbol(id))
  201.     CallError(stacktop,"setq: non-symbolic id",id,NONCONTINUABLE);
  202.  
  203.   if (CDR(forms)!=nil) 
  204.     CallError(stacktop,"setq: additional setq forms",nil,NONCONTINUABLE);
  205.  
  206.   while (reserved_symbol_p(id)) {
  207.     id = CallError(stacktop,"setq: reserved symbol",id,CONTINUABLE);
  208.   }
  209.   STACK_TMP(id);
  210.   forms = EUCALL_3(module_eval,mod,env,CAR(forms));
  211.   UNSTACK_TMP(id);
  212.   STACK_TMP(forms);
  213.   STACK_TMP(id);
  214.   env=ARG_1(stackbase);
  215.   while (env != NULL) {
  216.     if (env->ENV.variable == id) {
  217.       if (env->ENV.mutable) return (env->ENV.value = forms);
  218.       if (EUCALL_2(Fn_equal, forms, env->ENV.value)==nil) {
  219.     CallError(stacktop,"setq: immutable binding",id,NONCONTINUABLE);
  220.       }
  221.       return forms;
  222.     }
  223.     env = (LispObject) env->ENV.next;
  224.   }
  225.   UNSTACK_TMP(id);
  226.   UNSTACK_TMP(forms);
  227.   /* Going for the module environment */
  228.   mod=ARG_0(stackbase);
  229.   STACK_TMP(forms);
  230.   (void) EUCALL_3(module_set,mod,id,forms); /* In the module handler */
  231.   UNSTACK_TMP(forms);
  232.   return(forms);
  233.  
  234. }
  235. EUFUN_CLOSE
  236.  
  237. LispObject special_progn;
  238. EUFUN_3( Sf_progn, mod, env, forms)
  239. {
  240.   LispObject ret;
  241.  
  242.   if (!is_cons(forms))
  243.     CallError(stacktop,"progn: bad forms",forms,NONCONTINUABLE);
  244.  
  245.   ret = nil; /* Null case return value */
  246.  
  247.   while (is_cons(forms)) {
  248.     STACK_TMP(CDR(forms));
  249.     ret = EUCALL_3(module_eval,ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,CAR(forms));
  250.     UNSTACK_TMP(forms);
  251.   }
  252.  
  253.   return(ret);
  254. }
  255. EUFUN_CLOSE
  256.  
  257. LispObject special_if;
  258. EUFUN_3( Sf_if, mod, env, forms)
  259. {
  260.   LispObject pred,alt1,alt2;
  261.   LispObject debug;
  262.  
  263.   debug = forms;
  264.  
  265.   if (!is_cons(forms))
  266.     CallError(stacktop,"if: missing predicate",forms,NONCONTINUABLE);
  267.  
  268.   pred = CAR(forms); forms = CDR(forms);
  269.  
  270.   if (!is_cons(forms))
  271.     CallError(stacktop,"if: missing consequence",debug,NONCONTINUABLE);
  272.  
  273.   alt1 = CAR(forms); forms = CDR(forms);
  274.  
  275.   if (!is_cons(forms))
  276.     CallError(stacktop,"if: missing alternative",debug,NONCONTINUABLE);
  277.  
  278.   alt2 = CAR(forms); forms = CDR(forms);
  279.  
  280.   if (forms != nil)
  281.     CallError(stacktop,"if: extraneous forms",forms,NONCONTINUABLE);
  282.   
  283.   STACK_TMP(alt1);
  284.   STACK_TMP(alt2);
  285.   if (EUCALL_3(module_eval,mod,env,pred) != nil) {
  286.     UNSTACK_TMP(alt1); UNSTACK_TMP(alt1);
  287.     return(EUCALL_3(module_eval,ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,alt1));
  288.   }
  289.   else {
  290.     UNSTACK_TMP(alt2);
  291.     return(EUCALL_3(module_eval,ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,alt2));
  292.   }
  293. }
  294. EUFUN_CLOSE
  295.  
  296.  
  297. /*
  298.  
  299.  * Dynamics...
  300.  
  301.  */
  302.  
  303. LispObject special_dynamic_setq;
  304. EUFUN_3( Sf_dynamic_setq, mod, env, forms)
  305. {
  306.   LispObject id,form;
  307.   Env walker;
  308.  
  309.   if (!is_cons(forms))
  310.     CallError(stacktop,"dynamic-setq: missing symbol",forms,NONCONTINUABLE);
  311.  
  312.   id = CAR(forms); forms = CDR(forms);
  313.  
  314.   if (!is_symbol(id))
  315.     CallError(stacktop,"dynamic-setq: non-symbolic reference",id,NONCONTINUABLE);
  316.  
  317.   if (!is_cons(forms)) 
  318.     CallError(stacktop,"dynamic-setq: missing value form",forms,NONCONTINUABLE);
  319.  
  320.   form = CAR(forms); forms = CDR(forms);
  321.  
  322.   if (forms != nil)
  323.     CallError(stacktop,"dynamic-setq: extraneous forms",forms,NONCONTINUABLE);
  324.  
  325.   walker = DYNAMIC_ENV();
  326.  
  327.   while (walker != NULL) {
  328.     if (walker->variable == id)
  329.       {
  330.     STACK_TMPV(walker);
  331.     form = EUCALL_3(module_eval,mod,env,form);
  332.     UNSTACK_TMPV(walker);
  333.     return((walker->value = form));
  334.       }
  335.     walker = walker->next;
  336.   }
  337.  
  338.   if (id->SYMBOL.gvalue == NULL) {
  339.     fprintf(stderr,"****Illegal assignment to undeclared variable: ");
  340.     EUCALL_2(Fn_print,id,StdErr);
  341.     fprintf(stderr,"****Implicit defvar used\n");
  342.   }
  343.   STACK_TMP(id);
  344.   form = EUCALL_3(module_eval,mod,env,form);
  345.   UNSTACK_TMP(id);
  346.   return((id->SYMBOL.gvalue = form));
  347. }
  348. EUFUN_CLOSE
  349.  
  350. EUFUN_2( Fn_dynamic_setq, id, form)
  351. {
  352.   Env walker;
  353.  
  354.   if (!is_symbol(id))
  355.     CallError(stacktop,"(setter symbol-dynamic-value): non-symbolic reference",id,NONCONTINUABLE);
  356.  
  357.   walker = DYNAMIC_ENV();
  358.  
  359.   while (walker != NULL) {
  360.     if (walker->variable == id) return((walker->value = form));
  361.     walker = walker->next;
  362.   }
  363.  
  364.   if (id->SYMBOL.gvalue == NULL) {
  365.     fprintf(stderr,"****Illegal assignment to undeclared variable: ");
  366.     EUCALL_2(Fn_print,id,StdErr);
  367.     fprintf(stderr,"****Implicit defvar used\n");
  368.   }
  369.  
  370.   return((id->SYMBOL.gvalue = form));
  371. }
  372. EUFUN_CLOSE
  373.  
  374. LispObject special_dynamic_set;
  375. EUFUN_3( Sf_dynamic_set, mod, env, forms)
  376. {
  377.   LispObject id,form;
  378.   Env walker;
  379.  
  380.   if (!is_cons(forms))
  381.     CallError(stacktop,"dynamic-set: missing symbol",forms,NONCONTINUABLE);
  382.  
  383.   id = CAR(forms); forms = CDR(forms);
  384.  
  385.   id = EUCALL_3(module_eval,mod,env,id);
  386.  
  387.   if (!is_symbol(id))
  388.     CallError(stacktop,"dynamic-set: non-symbolic reference",id,NONCONTINUABLE);
  389.  
  390.   if (!is_cons(forms)) 
  391.     CallError(stacktop,"dynamic-set: missing value form",forms,NONCONTINUABLE);
  392.  
  393.   form = CAR(forms); forms = CDR(forms);
  394.  
  395.   if (forms != nil)
  396.     CallError(stacktop,"dynamic-set: extraneous forms",forms,NONCONTINUABLE);
  397.  
  398.   STACK_TMP(id);
  399.   form = EUCALL_3(module_eval,mod,env,form);
  400.   UNSTACK_TMP(id);
  401.   walker = DYNAMIC_ENV();
  402.  
  403.   while (walker != NULL) {
  404.     if (walker->variable == id) return((walker->value = form));
  405.     walker = walker->next;
  406.   }
  407.  
  408.   if (id->SYMBOL.gvalue == NULL) {
  409.     fprintf(stderr,"****Illegal assignment to undeclared variable: ");
  410.     EUCALL_2(Fn_print,id,StdErr);
  411.     fprintf(stderr,"****Implicit defvar used\n");
  412.   }
  413.  
  414.   return((id->SYMBOL.gvalue = form));
  415. }
  416. EUFUN_CLOSE
  417.  
  418. LispObject special_dynamic_let;
  419. EUFUN_3( Sf_dynamic_let, mod, env, forms)
  420. {
  421.   LispObject bindings;
  422.   Env save;
  423.  
  424.   if (!is_cons(forms))
  425.     CallError(stacktop,"dynamic-let: null forms",forms,NONCONTINUABLE);
  426.  
  427.   bindings = CAR(forms); forms = CDR(forms);
  428.  
  429.   if (!is_cons(bindings)) 
  430.     CallError(stacktop,
  431.           "dynamic-let: invalid binding forms",bindings,NONCONTINUABLE);
  432.  
  433.   save = DYNAMIC_ENV(); /* Hang on for exit... */
  434.   
  435.   STACK_TMPV(save);
  436.   STACK_TMP(forms); 
  437.   while (is_cons(bindings)) {
  438.     LispObject id,val,bind;
  439.     LispObject xx;
  440.  
  441.     bind = CAR(bindings);
  442.     STACK_TMP(CDR(bindings));
  443.     if (!is_cons(bind))
  444.       CallError(stacktop,
  445.         "dynamic-let: weird binding",bindings,NONCONTINUABLE);
  446.  
  447.     id = CAR(bind); bind = CDR(bind);
  448.  
  449.     if (!is_symbol(id)) 
  450.       CallError(stacktop,"dynamic-let: non-symbolic var",id,NONCONTINUABLE);
  451.  
  452.     if (!is_cons(bind))
  453.       CallError(stacktop,"dynamic-let: weird binding",bindings,NONCONTINUABLE);
  454.  
  455.     val = CAR(bind);
  456.  
  457.     STACK_TMP(id);
  458.     val = EUCALL_3(module_eval,ARG_0(stackbase),ARG_1(stackbase),val);
  459.     UNSTACK_TMP(id);
  460.  
  461.     xx = allocate_env(stacktop,id,val,
  462.               ((LispObject)(DYNAMIC_ENV())));
  463.     DYNAMIC_ENV()=&xx->ENV;
  464.     UNSTACK_TMP(bindings);
  465.   }
  466.   UNSTACK_TMP(forms);
  467.   /* Do body... */
  468.   forms = EUCALL_3(Sf_progn,ARG_0(stackbase),ARG_1(stackbase),forms);
  469.   UNSTACK_TMPV(save);
  470.   
  471.   DYNAMIC_ENV() = save; /* Repoint */
  472.  
  473.   return(forms);
  474. }
  475. EUFUN_CLOSE    
  476.  
  477. EUFUN_1( Fn_dynamic, form)
  478. {
  479.   {
  480.     Env ee = DYNAMIC_ENV();
  481.     while (ee!=NULL) {
  482.       if (ee->variable == form) return ee->value;
  483.       ee = ee->next;
  484.     }
  485.   }
  486.   {
  487.     LispObject ans;
  488.     ans =  (form->SYMBOL).gvalue;
  489.     if (ans==NULL) {        /* signal UNBOUND_DYNAMIC_VARIABLE */
  490.       ans = CallError(stacktop,"Unset dynamic variable ",form,CONTINUABLE);
  491.       (form->SYMBOL).gvalue = ans;
  492.     }
  493.     return ans;
  494.   }
  495. }
  496. EUFUN_CLOSE
  497.  
  498. LispObject special_dynamic;
  499. EUFUN_3( Sf_dynamic, mod, env, form)
  500. {
  501.   IGNORE(mod); IGNORE(env);
  502.  
  503.   while (!is_symbol(CAR(form)) || CDR(form)!=nil)
  504.     form = CallError(stacktop,"dynamic: Illegal dynamic form ",form,CONTINUABLE);
  505.  
  506.   form = CAR(form);
  507.  
  508.   {
  509.     Env ee = DYNAMIC_ENV();
  510.     while (ee!=NULL) {
  511.       if (ee->variable == form) return ee->value;
  512.       ee = ee->next;
  513.     }
  514.   }
  515.   {
  516.     LispObject ans;
  517.     ans =  (form->SYMBOL).gvalue;
  518.     if (ans==NULL) {        /* signal UNBOUND_DYNAMIC_VARIABLE */
  519.       ans = CallError(stacktop,"dynamic: unset dynamic variable ",form,CONTINUABLE);
  520.       (form->SYMBOL).gvalue = ans;
  521.     }
  522.     return ans;
  523.   }
  524. }
  525. EUFUN_CLOSE
  526.  
  527. LispObject special_quote;
  528. EUFUN_3( Sf_quote, mod, env, forms)
  529. {
  530.   IGNORE(mod); IGNORE(env);
  531.  
  532.   if (!is_cons(forms))
  533.     CallError(stacktop,"quote: bad forms",forms,NONCONTINUABLE);
  534.  
  535.   return(CAR(forms));
  536. }
  537. EUFUN_CLOSE
  538.  
  539. /*
  540.  
  541.  * Handlers...
  542.  
  543.  */
  544.  
  545. /* Hack... */
  546.  
  547. LispObject special_evalcm;
  548. EUFUN_3(Sf_evalcm, mod, env, form)
  549. {
  550.   LispObject ans;
  551.  
  552.   if (!is_cons(form))
  553.     CallError(stacktop,"eval/cm: no arguments",form,NONCONTINUABLE);
  554.  
  555.   if (is_cons(CDR(form)))
  556.     CallError(stacktop,"eval/cm: too many arguments",form,NONCONTINUABLE);
  557.  
  558.   form = EUCALL_3(module_eval,mod,env,form);
  559.  
  560.   ans = EUCALL_2(process_top_level_form,mod,CAR(form));
  561.  
  562.   return(ans);
  563. }
  564. EUFUN_CLOSE
  565.  
  566. /* Tag Body... */
  567.  
  568. /*
  569.  
  570.  * 'tagbody'
  571.  *
  572.  *   Plan: Do a naive walk on the body to extract a table of symbols with
  573.  *         following code, rig a continuation for 'go' statements to jump
  574.  *         to and run them in sequence until done...
  575.  
  576.  */
  577.  
  578. /* ******************** This function cannot be called *************** */
  579. static LispObject tagbody_before_label(LispObject *stacktop,LispObject body)
  580. {
  581.   if (!is_cons(body)) return(nil);
  582.   if (is_symbol(CAR(body))) return(nil);
  583.  
  584.   return(EUCALL_2(Fn_cons,CAR(body),tagbody_before_label(stacktop,CDR(body))));
  585. }
  586.  
  587. static LispObject tagbody_suck_symbols(LispObject *stacktop,LispObject body)
  588. {      
  589.   LispObject xx;
  590.   if (!is_cons(body)) return(nil);
  591.   if (is_symbol(CAR(body))) return(tagbody_suck_symbols(stacktop,CDR(body)));
  592.  
  593.   STACK_TMP(body);
  594.   xx=tagbody_suck_symbols(stacktop,CDR(body));
  595.   UNSTACK_TMP(body);
  596.   return(EUCALL_2(Fn_cons,CAR(body),xx));
  597. }
  598.  
  599. static LispObject tagbody_handle;
  600.  
  601. LispObject special_tagbody;
  602. EUFUN_3( Sf_tagbody, mod, env, forms)
  603. {
  604.   LispObject table,cont;
  605.   LispObject walker;
  606.   LispObject before;
  607.   LispObject res;
  608.  
  609.   table = (LispObject) allocate_table(stacktop,Fn_eq);
  610.   STACK_TMP(table);
  611.   before = nil;
  612.   before = tagbody_suck_symbols(stacktop,ARG_2(stackbase));
  613.   UNSTACK_TMP(table);
  614.   
  615.   walker = ARG_2(stackbase) /*forms*/;
  616.   while (is_cons(walker)) {
  617.     if (is_symbol(CAR(walker))) break;
  618.     walker = CDR(walker);
  619.   }
  620.  
  621.   if (is_cons(walker)) 
  622.     {
  623.       LispObject augenv;
  624.       LispObject runbody;
  625.  
  626.       /* Non-trivial label forms... */
  627.       stacktop+=2;
  628.       ARG_2(stackbase)=before;    /* kill forms*/
  629.       *(stackbase+3)=table;
  630.       *(stackbase+4)=nil;
  631.       STACK_TMP(walker);
  632.       cont = allocate_continue(stacktop);
  633.       *(stackbase+4)=cont;
  634.       
  635.       UNSTACK_TMP(walker);
  636.       do {
  637.     LispObject label, body;
  638.     label = CAR(walker); walker = CDR(walker);
  639.     STACK_TMP(walker);
  640.     STACK_TMP(label);
  641.     body = tagbody_suck_symbols(stacktop,walker);
  642.     UNSTACK_TMP(label);
  643.     EUCALL_3(tref_updator,*(stackbase+3)/*table*/,label,body);
  644.     UNSTACK_TMP(walker);
  645.  
  646.     while (is_cons(walker))
  647.       {
  648.         if (is_symbol(CAR(walker))) break;
  649.         walker = CDR(walker);
  650.       }
  651.       } while (is_cons(walker));
  652.  
  653.       /* Construct the augmented environment... */
  654.  
  655.       augenv = allocate_env(stacktop,tagbody_handle,*(stackbase+4)/*cont*/,ARG_1(stackbase));
  656.       ARG_1(stackbase)=augenv;
  657.  
  658.       runbody = ARG_2(stackbase)/*before*/;
  659.  
  660.       STACK_TMP(augenv);
  661.     reset:
  662.  
  663.       /* Go continuation... */
  664.  
  665.       if (set_continue(stacktop,*(stackbase+4)/*cont*/)) {
  666.     
  667.     /* Go has been called... */
  668.     
  669.     runbody = EUCALL_2(Fn_tref,*(stackbase+3)/*table*/,(*(stackbase+4))/*cont*/->CONTINUE.value);
  670.     
  671.     if (runbody == nil)
  672.       CallError(stacktop,
  673.             "go: no such label",cont->CONTINUE.value,NONCONTINUABLE);
  674.     goto reset;
  675.       }
  676.     
  677.       res = EUCALL_3(Sf_progn,ARG_0(stackbase)/*mod*/,(LispObject)ARG_1(stackbase)/*augenv*/,runbody);
  678.       unset_continue((*(stackbase+4)));
  679.  
  680.       return(res);
  681.     }
  682.   else
  683.     {    /* The easy way... */
  684.       res = EUCALL_3(Sf_progn,ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,before);
  685.       return(res);
  686.     }
  687. }
  688. EUFUN_CLOSE
  689.  
  690. LispObject special_go;
  691. EUFUN_3( Sf_go, mod, env, forms)
  692. {
  693.   LispObject tag;
  694.   Env walker;
  695.  
  696.   IGNORE(mod);
  697.  
  698.   if (!is_cons(forms))
  699.     CallError(stacktop,"go: no tag",forms,NONCONTINUABLE);
  700.  
  701.   tag = CAR(forms);
  702.  
  703.   if (!is_symbol(tag))
  704.     CallError(stacktop,"go: non-symbolic tag",tag,NONCONTINUABLE);
  705.  
  706.   walker = (Env)env;
  707.   while (walker != NULL) {
  708.     if (walker->variable == tagbody_handle)
  709.       call_continue(stacktop,walker->value,tag);
  710.     walker = walker->next;
  711.   }
  712.  
  713.   CallError(stacktop,"go: not within tagbody",nil,NONCONTINUABLE);
  714.  
  715.   return(nil);
  716. }
  717. EUFUN_CLOSE
  718.  
  719. void initialise_specials(LispObject *stacktop)
  720. {
  721.   special_table = (LispObject) allocate_table(stacktop,Fn_eq);
  722.   add_root(&special_table);
  723.   
  724.   special_lambda = my_make_special(stacktop,"lambda",Sf_lambda);
  725.   add_root(&special_lambda);
  726.   special_macro_lambda = my_make_special(stacktop,"macro-lambda",Sf_mlambda);
  727.   add_root(&special_macro_lambda);
  728.   special_setq   = my_make_special(stacktop,"setq",Sf_setq);
  729.   add_root(&special_setq);
  730.   special_progn  = my_make_special(stacktop,"progn",Sf_progn);
  731.   add_root(&special_progn);
  732.   special_if     = my_make_special(stacktop,"if",Sf_if);
  733.   add_root(&special_if);
  734.   
  735. /*  last_continue = nil;*/
  736.  
  737.   special_dynamic_setq = my_make_special(stacktop,"dynamic-setq",Sf_dynamic_setq);
  738.   add_root(&special_dynamic_setq);
  739.   special_dynamic_set  = my_make_special(stacktop,"dynamic-set",Sf_dynamic_set);
  740.   add_root(&special_dynamic_set);
  741.   special_dynamic_let  = my_make_special(stacktop,"dynamic-let",Sf_dynamic_let);
  742.   add_root(&special_dynamic_let);
  743.   special_dynamic      = my_make_special(stacktop,"dynamic",Sf_dynamic);
  744.   add_root(&special_dynamic_let);
  745.   
  746.   special_quote = my_make_special(stacktop,"quote",Sf_quote);
  747.   add_root(&special_quote);
  748.   
  749.   special_tagbody = my_make_special(stacktop,"tagbody",Sf_tagbody);
  750.   add_root(&special_tagbody);
  751.   tagbody_handle = get_symbol(stacktop,"***tagbody-handle***");
  752.   add_root(&tagbody_handle);
  753.   special_go = my_make_special(stacktop,"go",Sf_go);
  754.   add_root(&special_go);
  755. }
  756.  
  757.